Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue42/system/UCAniIcon.pas

Pascal/Delphi Source File | 1999-01-03 | 12.5 KB | 381 lines

unit UCAniIcon;

interface

uses Windows, SysUtils, Consts, Classes, Graphics;

type
    TAniIconHeader = record
        dwSizeof: LongInt;
        dwFrames: LongInt;
        dwSteps: LongInt;
        dwCX: LongInt;                    { use this to store icon width }
        dwCY: LongInt;                    { use this to store icon height }
        dwBitCount: LongInt;
        dwPlanes: LongInt;
        dwJIFRate: LongInt;
        dwFlags: LongInt;
    end;

    TAniIcon = class (TGraphic)
    private
        Rates: TList;                     { Optional JIFRate info for each step }
        FrameOffsets: TList;              { Stream offsets into each frame }
        SequenceMap: TList;               { Optional frame sequence mapping }
        Image: TMemoryStream;             { Memory Image of entire .ANI file }
        fAuthor: String;                  { Optional author information }
        fTitle: String;                   { Optional title information }
        fHeader: TAniIconHeader;          { ANI header extracted from file }
        fCurrentJIFs: Integer;            { current JIF count for this step }
        fCurrentStep: Integer;            { current step number }
        fCurrentFrame: Integer;           { currently displaying frame number }
        fCurrentIcon: hIcon;              { currently displaying icon }
        fTransparent: Boolean;            { for transparent blitting }
        fBackColor: TColor;               { background color when not transparent }
        procedure SetFrame (Index: Integer);
    public
        procedure Clear;
        constructor Create; override;
        destructor Destroy; override;
        procedure Assign (Source: TPersistent); override;
        procedure LoadFromStream (Stream: TStream); override;
        procedure SaveToStream (Stream: TStream); override;
        procedure Animate;
        procedure LoadFromClipboardFormat (AFormat: Word; AData: THandle; APalette: HPalette); override;
        procedure SaveToClipboardFormat (var Format: Word; var Data: THandle; var APalette: HPalette); override;
        procedure Draw (ACanvas: TCanvas; const Rect: TRect); override;
        procedure SetAnimatedCursor (Index: Integer);
        property Author: String read fAuthor;
        property Title: String read fTitle;
        property Icon: hIcon read fCurrentIcon;
        property Transparent: Boolean read fTransparent write fTransparent default False;
        property BackgroundColor: TColor read fBackColor write fBackColor default clBtnFace;
    protected
        function GetEmpty: Boolean; override;
        function GetHeight: Integer; override;
        function GetWidth: Integer; override;
        procedure SetHeight (Value: Integer); override;
        procedure SetWidth (Value: Integer); override;
    end;

implementation

{ TAniIcon }

uses Forms;

constructor TAniIcon.Create;
begin
    Inherited Create;
    fTransparent := False;
    fBackColor := clBtnFace;
    Rates := TList.Create;
    FrameOffsets := TList.Create;
    SequenceMap := TList.Create;
    Image := TMemoryStream.Create;
end;

destructor TAniIcon.Destroy;
begin
    Clear;
    Image.Free;
    Rates.Free;
    FrameOffsets.Free;
    SequenceMap.Free;
    Inherited Destroy;
end;

procedure TAniIcon.Clear;
begin
    fAuthor := '--unavailable--';
    fTitle := '--unavailable--';
    Image.Clear;
    Rates.Clear;
    FrameOffsets.Clear;
    SequenceMap.Clear;
    if fCurrentIcon <> 0 then DestroyIcon (fCurrentIcon);
    fCurrentIcon := 0;
    fCurrentJIFs := 0;
    fCurrentStep := 0;
    fCurrentFrame := 0;
end;

procedure TAniIcon.Assign (Source: TPersistent);
begin
    if Source = Nil then Clear
    else if Source is TAniIcon then LoadFromStream (TAniIcon (Source).Image)
    else Inherited Assign (Source);
end;

function TAniIcon.GetEmpty: Boolean;
begin
    Result := FrameOffsets.Count = 0;
end;

procedure TAniIcon.SetHeight (Value: Integer);
begin
    raise EInvalidGraphicOperation.Create (sChangeIconSize);
end;

procedure TAniIcon.SetWidth (Value: Integer);
begin
    raise EInvalidGraphicOperation.Create (sChangeIconSize);
end;

function TAniIcon.GetWidth: Integer;
begin
    Result := fHeader.dwCX;
end;

function TAniIcon.GetHeight: Integer;
begin
    Result := fHeader.dwCY;
end;

procedure TAniIcon.LoadFromClipboardFormat (AFormat: Word; AData: THandle; APalette: HPalette);
begin
    raise EInvalidGraphicOperation.Create (sIconToClipboard);
end;

procedure TAniIcon.SaveToClipboardFormat (var Format: Word; var Data: THandle; var APalette: HPalette);
begin
    raise EInvalidGraphicOperation.Create (sIconToClipboard);
end;

procedure TAniIcon.LoadFromStream (Stream: TStream);
const
    sig_RIFF = $46464952;         { RIFF header                         }
    sig_ACON = $4E4F4341;         { ACON form type                      }
    sig_LIST = $5453494C;         { LIST sub-chunk                      }
    sig_INFO = $4F464E49;         { INFO sub-chunk                      }
    sig_INAM = $4D414E49;         { INAM - title information            }
    sig_IART = $54524149;         { IART - author information           }
    sig_anih = $68696E61;         { anih - header information           }
    sig_rate = $65746172;         { optional JIF rates sub-chunk        }
    sig_fram = $6D617266;         { fram - list of icon frames          }
    sig_icon = $6E6F6369;         { icon - start of actual frame        }
    sig_seq  = $20716573;         { seq - optional sequence information }

var
    ChunkLen: LongInt;
    EncounteredHeader: Boolean;

    procedure InvalidFile;
    begin
        raise EInvalidGraphic.Create ('Animated icon image is not valid');
    end;

    function ReadByte: Byte;
    begin
        Image.ReadBuffer (Result, sizeof (Result));
    end;

    function ReadLong: LongInt;
    begin
        Image.ReadBuffer (Result, sizeof (Result));
    end;

    function ReadString: String;
    var
        p: PChar;
        Len: LongInt;
    begin
        Len := ReadLong;
        if (Len and 1) <> 0 then Inc (Len);
        GetMem (p, Len + 1);
        p[Len] := #0;
        Image.ReadBuffer (p^, Len);
        Result := StrPas (p);
        FreeMem (p, Len + 1);
    end;

    { Process an optional info header sub-chunk. Contains Title/Author }
    procedure ParseTitleAuthor;
    var
        ChunkEnd: LongInt;
    begin
        ChunkEnd := ReadLong;
        Inc (ChunkEnd, Image.Position);
        if ReadLong <> sig_INFO then InvalidFile;

        while Image.Position < ChunkEnd do
            case ReadLong of
                sig_INAM: fTitle := ReadString;
                sig_IART: fAuthor := ReadString;
            end;
    end;

    { Parse ANI header information }
    procedure ParseAniHeader;
    begin
        if ReadLong <> sizeof (fHeader) then InvalidFile;
        Image.ReadBuffer (fHeader, sizeof (fHeader));
        EncounteredHeader := True;
    end;

    { Parse optional JIFRates chunk OR }
    {       optional Sequence Map      }
    procedure ParseList (List: TList);
    var
        Len: LongInt;
    begin
        Len := ReadLong div sizeof (LongInt);
        if Len <> fHeader.dwSteps then InvalidFile;
        while Len > 0 do begin
            List.Add (Pointer (ReadLong));
            Dec (Len);
        end;
    end;

    { Parse the actual icon data itself }
    procedure ParseIconList;
    var
        Idx: Integer;
        Len, Next: LongInt;
    begin
        ReadLong; { Discard chunk length }
        if ReadLong <> sig_fram then InvalidFile;
        { Store frame offsets for later consumption }
        for Idx := 0 to fHeader.dwFrames - 1 do begin
            if ReadLong <> sig_icon then InvalidFile;
            { Save position from beginning of length dword }
            FrameOffsets.Add (Pointer (Image.Position));
            { Read Length of this frame }
            Len := ReadLong;
            Next := Len + Image.Position;
            { Dig a little deeper to get the icon size info }
            if Idx = 0 then begin
                Image.Position := Image.Position + 6;
                fHeader.dwCX := ReadByte;
                fHeader.dwCY := ReadByte;
            end;

            Image.Position := Next;
        end;
    end;

begin { LoadFromStream }
    Clear;
    { If stream size is 0, we're done }
    if Stream.Size = 0 then Exit;
    Image.LoadFromStream (Stream);
    EncounteredHeader := False;
    { Validate initial eight-byte header }
    { Note: Some .ANI files have filesize > header (e.g. appstart.ani) }
    if (ReadLong <> sig_RIFF) or (ReadLong > Image.Size) then InvalidFile;
    { Next item must be an ACON chunk }
    if ReadLong <> sig_ACON then InvalidFile;

    while Image.Position < Image.Size do
        { Case out on the sub-chunk we find }
        case ReadLong of
            sig_LIST: if not EncounteredHeader then ParseTitleAuthor else ParseIconList;
            sig_anih: ParseAniHeader;
            sig_rate: ParseList (Rates);
            sig_seq:  ParseList (SequenceMap);

            else      begin { Unknown chunk - just skip it }
                          ChunkLen := ReadLong;
                          Image.Position := Image.Position + ChunkLen;
                      end;
        end;

    SetFrame (0);
end;

procedure TAniIcon.SaveToStream (Stream: TStream);
begin
    if GetEmpty then raise EInvalidGraphicOperation.Create (sInvalidImage);
    with Image do Stream.WriteBuffer (Memory^, Size);
end;

procedure TAniIcon.Draw (ACanvas: TCanvas; const Rect: TRect);
var
    bm: TBitmap;
begin
    if fCurrentIcon <> 0 then begin
        if not fTransparent then begin
            bm := TBitmap.Create;
            bm.Width := fHeader.dwCX;
            bm.Height := fHeader.dwCY;
            bm.Canvas.Brush.Color := fBackColor;
            bm.Canvas.FillRect (Classes.Rect (0, 0, bm.Width, bm.Height));
            DrawIcon (bm.Canvas.Handle, 0, 0, fCurrentIcon);
            ACanvas.Draw (Rect.Left, Rect.Top, bm);
            bm.Free;
        end else DrawIcon (ACanvas.Handle, Rect.Left, Rect.Top, fCurrentIcon);
    end;
end;

procedure TAniIcon.SetFrame (Index: Integer);
type
    TIconHeader = packed record
        AlwaysZero: Word;
        CursorType: Word;
        NumIcons: Word;
    end;

    TIconDirEntry = packed record
        Width, Height, Colors: Byte;
        Reserved: Byte;
        dwReserved: LongInt;
        dwBytesInRes: LongInt;
        dwImageOffset: LongInt;
    end;

var
    p: PByte;
    ChunkLen: LongInt;
    IconHeader: TIconHeader;
begin
    if (FrameOffsets.Count <> 0) and (Index < fHeader.dwFrames) then begin
       fCurrentFrame := Index;
       // Delete any existing icon
       if fCurrentIcon <> 0 then DestroyIcon (fCurrentIcon);
       // Seek to wanted position in stream data
       Image.Position := Integer (FrameOffsets [Index]);
       Image.ReadBuffer (ChunkLen, sizeof (ChunkLen));
       Image.ReadBuffer (IconHeader, sizeof (IconHeader));
       Image.Position := Image.Position + (sizeof (TIconDirEntry) * IconHeader.NumIcons);
       Dec (ChunkLen, sizeof (IconHeader) + (sizeof (TIconDirEntry) * IconHeader.NumIcons));

       p := Image.Memory; Inc (p, Image.Position);
       fCurrentIcon := CreateIconFromResource (p, ChunkLen, True, $30000);
       Changed (Self);
    end;
end;

procedure TAniIcon.Animate;
var
    JifRate, NextFrame: Integer;
begin
    if Rates.Count = 0 then JifRate := fHeader.dwJIFRate else JifRate := Integer (Rates [fCurrentStep]);
    Inc (fCurrentJIFs, 4);
    if fCurrentJIFs >= JifRate then begin
        { Time to move on to next step }
        fCurrentJIFs := 0;
        Inc (fCurrentStep);
        if fCurrentStep >= fHeader.dwSteps then fCurrentStep := 0;
        if SequenceMap.Count = 0 then NextFrame := fCurrentFrame + 1 else NextFrame := Integer (SequenceMap [fCurrentStep]);
        if NextFrame >= fHeader.dwFrames then NextFrame := 0;
        if NextFrame <> fCurrentFrame then SetFrame (NextFrame);
    end;
end;

procedure TAniIcon.SetAnimatedCursor (Index: Integer);
var
    TempFileName: String;
begin
    if not Empty then begin
        TempFileName := FormatDateTime ('__$$hhnnss$$__', Now);
        SaveToFile (TempFileName);
        try
            Screen.Cursors [Index] := LoadImage (0, PChar (TempFileName), Image_Cursor, 0, 0, lr_LoadFromFile);
        finally
        DeleteFile (TempFileName);
        end;
    end;
end;

end.